home *** CD-ROM | disk | FTP | other *** search
/ Developer CD Series 1993…ch: Other People's Memory / ADC Developer CD (1993-03) (''Other People's Memory'')_iso / Dev.CD Mar 93.iso / Development Platforms / LISP Related / LISP Goodies / AV Parser / AV Program / Grammar Reader Grammar.Lisp < prev    next >
Encoding:
Text File  |  1992-09-02  |  7.4 KB  |  190 lines  |  [TEXT/CCL2]
  1.  
  2. (defparameter *ugrammar*
  3.   '((avsgl --> init statements
  4.            #'(lambda (i s)
  5.                (unless *start-cat*
  6.                  (format t "~%Warning: The start category has not been defined")
  7.                  (format t "~% (Set to an uninstantiated category)")
  8.                  (setq *start-cat* (make-avnode)))
  9.                (unless *restrictor-cat*
  10.                  (format t "~%Warning:  The restrictor has not been defined")
  11.                  (format t "~% (Set to an uninstantiated category, ie. bottom-up)")
  12.                  (setq *restrictor-cat* (make-avnode)))
  13.                (list *rules* *lexical-entries* *start-cat* *restrictor-cat*)))
  14.     (init -->
  15.           #'(lambda ()
  16.               (setq *rules* '())
  17.               (setq *lexical-entries* '())
  18.               (setq *start-cat* nil)
  19.               (setq *restrictor-cat* nil)
  20.               (setq *vars* '())
  21.               (setq *val-prefix* 'val)
  22.               (setq *cat-prefix* 'cat)))
  23.     (statements -->
  24.                 #'nullfn)
  25.     (statements --> statements statement #\.
  26.                 #'nullfn)
  27.     (statement --> vars
  28.                #'nullfn)
  29.     (statement --> start-cat
  30.                #'nullfn)
  31.     (statement --> cat-prefix
  32.                #'nullfn)
  33.     (statement --> val-prefix
  34.                #'nullfn)
  35.     (statement --> restrict
  36.                #'nullfn)
  37.     (statement --> lexical-entry
  38.                #'nullfn)
  39.     (statement --> rule
  40.                #'nullfn)
  41.     (vars --> variables #\= symbol-list
  42.                #'(lambda (v e vars)
  43.                    (setq *vars* vars)))
  44.     (start-cat --> start-category #\: #\= cat
  45.                #'(lambda (s co e cat)
  46.                    (when *start-cat*
  47.                      (format t "~%Warning:  Resetting start category"))
  48.                    (setq *start-cat* cat)))
  49.     (cat-prefix --> category-prefix #\= symbol-or-nil
  50.                 #'(lambda (cp c symbol)
  51.                     (setq *cat-prefix* symbol)))
  52.     (val-prefix --> value-prefix #\= symbol-or-nil
  53.                 #'(lambda (vp c symbol)
  54.                     (setq *val-prefix* symbol)))
  55.     (symbol-or-nil --> symbol
  56.                    #'identity)
  57.     (symbol-or-nil -->
  58.                    #'nullfn)
  59.     (restrict --> restrictor #\: #\= cat
  60.                 #'(lambda (r co e cat)
  61.                     (when *restrictor-cat*
  62.                       (format t "~%Warning:  Resetting restrictor category"))
  63.                     (setq *restrictor-cat* cat)))
  64.     (lexical-entry --> lex-form lex-cat #\: cat
  65.                    #'(lambda (lf lex-cat c cat)
  66.                        (let ((entry (assoc lf *lexical-entries*)))
  67.                          (if entry
  68.                            (push cat (cdr entry))
  69.                            (push (list lf cat)    ; because LoadWords expects a list of categories!
  70.                                  *lexical-entries*)))))
  71.     (lex-form --> symbol
  72.                 #'(lambda (s)
  73.                     (setq *current-form* `(|lexical entry| ,s))
  74.                     s))
  75.     (lex-cat -->
  76.              #'nullfn)
  77.     (lex-cat --> symbol
  78.              #'(lambda (lex-cat)
  79.                  (unify-avs (make-att-val (make-att-val *u-env* 'root)
  80.                                           *cat-prefix*) lex-cat)))
  81.     (rule --> rule-cats #\: eqns*
  82.           #'(lambda (ndaughters colon eqns)
  83.               (Reset-Copier)
  84.               (push (make-rule :mother (copy-avs (make-att-val *u-env* -1))
  85.                                :daughters (let (result)
  86.                                             (dotimes (i ndaughters)
  87.                                               (push (copy-avs (make-att-val *u-env* i)) result))
  88.                                             (nreverse result)))
  89.                     *rules*)
  90.               (New-Generation)))
  91.     (rule-cats --> symbol-or-underline --> symbol-list
  92.                #'(lambda (mother a daughters)
  93.                    (setq *current-form* `(|syntactic rule| ,mother --> ,@daughters))
  94.                    (when *cat-prefix*
  95.                      (unless (eq mother 'underline)
  96.                        (unify-avs (make-att-val (make-att-val *u-env* -1) *cat-prefix*) 
  97.                                   mother))
  98.                      (dotimes (i (length daughters))
  99.                        (unless (eq (nth i daughters) 'underline)
  100.                          (unify-avs (make-att-val (make-att-val *u-env* i) *cat-prefix*)
  101.                                     (nth i daughters)))))
  102.                    (length daughters)))
  103.     (symbol-list -->
  104.                  #'nullfn)
  105.     (symbol-list --> symbol symbol-list
  106.                  #'cons)
  107.     (symbol-list --> #\_ symbol-list
  108.                  #'(lambda (u ss)
  109.                      (cons 'underline ss)))
  110.     (symbol-or-underline --> symbol
  111.                          #'identity)
  112.     (symbol-or-underline --> #\_
  113.                          #'(lambda (u) 'underline))
  114.     (cat --> eqns*
  115.          #'(lambda (e)
  116.              (Reset-Copier)
  117.              (let ((value (copy-avs (make-att-val *u-env* 'root))))
  118.                (New-Generation)
  119.                value)))
  120.     (eqns* --> 
  121.            #'nullfn)
  122.     (eqns* --> eqns 
  123.            #'nullfn)
  124.     (eqns --> eqns #\, eqn
  125.           #'nullfn)
  126.     (eqns --> eqn
  127.           #'nullfn)
  128.     (eqn --> path #\= path
  129.          #'(lambda (p1 e p2)
  130.              (if (null (unify-avs p1 p2))
  131.                (error "~%Warning: Failed unification in ~{~a ~}" *current-form*))))
  132.     (path --> symbol #\( path #\)
  133.           #'(lambda (symbol left path right)
  134.               (make-att-val path symbol)))
  135.     (path --> symbol
  136.           #'(lambda (s)
  137.               (if (member s *vars*)
  138.                 (make-att-val *u-env* s)
  139.                 s)))
  140.     (path --> #\*
  141.           #'(lambda (s)
  142.               (if *val-prefix*
  143.                 (make-att-val (make-att-val *u-env* 'root) *val-prefix*)
  144.                 (make-att-val *u-env* 'root))))
  145.     (path --> #\* #\*
  146.           #'(lambda (s1 s2)
  147.               (make-att-val *u-env* 'root)))
  148.     (path --> #\_
  149.           #'(lambda (u)
  150.               (make-avnode)))
  151.     (path --> #\* symbol
  152.           #'(lambda (s sym)
  153.               (if (integerp sym)
  154.                 (if *val-prefix*
  155.                   (make-att-val (make-att-val *u-env* (1- sym)) *val-prefix*)
  156.                   (make-att-val *u-env* (1- sym)))
  157.                 (error "~%Illegal use of *~a in ~{~a ~}" sym *current-form*))))
  158.     (path --> #\* #\* symbol
  159.           #'(lambda (s1 s2 sym)
  160.               (if (integerp sym)
  161.                 (make-att-val *u-env* (1- sym))
  162.                 (error "~%Illegal use of *~a in ~{~a ~}" sym *current-form*))))
  163.     (path --> #\[ #\]
  164.           #'(lambda (lb rb)
  165.               'none))
  166.     (path --> #\[ list-path #\]
  167.           #'(lambda (lb value rb)
  168.               value))
  169.     (list-path --> path
  170.           #'(lambda (head)
  171.               (let ((node (make-avnode)))
  172.                 (unify-avs (make-att-val node 'first) head)
  173.                 (unify-avs (make-att-val node 'rest) 'none)
  174.                 node)))
  175.     (list-path --> path #\, list-path
  176.           #'(lambda (head comma tail)
  177.               (let ((node (make-avnode)))
  178.                 (unify-avs (make-att-val node 'first) head)
  179.                 (unify-avs (make-att-val node 'rest) tail)
  180.                 node)))
  181.     (list-path --> path #\| path
  182.           #'(lambda (head comma tail)
  183.               (let ((node (make-avnode)))
  184.                 (unify-avs (make-att-val node 'first) head)
  185.                 (unify-avs (make-att-val node 'rest) tail)
  186.                 node)))
  187.     ))
  188.  
  189. ; (eval (Lalr:Make-Parser *ugrammar* *ulexforms* '|#]|))
  190.